home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue42 / system / UCAniTrayIcon.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1999-01-01  |  4.4 KB  |  160 lines
  1. unit UCAniTrayIcon;
  2.  
  3. interface
  4.  
  5. uses
  6.     Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.     StdCtrls, UCAniIcon;
  8.  
  9. const
  10.     UCTrayCallBack = $89AB;
  11.  
  12. type
  13.     TUCAniTrayIcon = class (TComponent)
  14.     private
  15.         { Private declarations }
  16.         fHint: String;
  17.         fWindowHandle: hWnd;
  18.         fVisible: Boolean;
  19.         fAniIcon: TAniIcon;
  20.         fOnLeftClick: TNotifyEvent;
  21.         fOnRightClick: TNotifyEvent;
  22.         fExclusionLock: Boolean;
  23.         fAnimate: Boolean;
  24.         procedure SetHint (const Value: String);
  25.         procedure SetVisible (Value: Boolean);
  26.         procedure SetAniIcon (Value: TAniIcon);
  27.         procedure UpdateTray (Visible: Boolean);
  28.         procedure SetAnimate (Value: Boolean);
  29.         procedure WndProc (var Message: TMessage);
  30.         procedure TrayMessage (var Message: TMessage);
  31.     protected
  32.         { Protected declarations }
  33.         procedure Loaded; override;
  34.     public
  35.         { Public declarations }
  36.         constructor Create (AOwner: TComponent); override;
  37.         destructor Destroy; override;
  38.     published
  39.         { Published declarations }
  40.         property Icon: TAniIcon read fAniIcon write SetAniIcon;
  41.         property Hint: String read fHint write SetHint;
  42.         property Animate: Boolean read fAnimate write SetAnimate default False;
  43.         property Visible: Boolean read fVisible write SetVisible default False;
  44.         property OnLeftClick: TNotifyEvent read fOnLeftClick write fOnLeftClick;
  45.         property OnRightClick: TNotifyEvent read fOnRightClick write fOnRightClick;
  46.     end;
  47.  
  48. procedure Register;
  49.  
  50. implementation
  51.  
  52. uses ShellAPI;
  53.  
  54. constructor TUCAniTrayIcon.Create (AOwner: TComponent);
  55. begin
  56.     Inherited Create (AOwner);
  57.     fWindowHandle := AllocateHWnd (WndProc);
  58.     fAniIcon := TAniIcon.Create;
  59. end;
  60.  
  61. procedure TUCAniTrayIcon.Loaded;
  62. begin
  63.     Inherited Loaded;
  64.     UpdateTray (fVisible);
  65. end;
  66.  
  67. destructor TUCAniTrayIcon.Destroy;
  68. begin
  69.     SetAnimate (False);
  70.     SetVisible (False);
  71.     DeallocateHWnd (fWindowHandle);
  72.     fAniIcon.Free;
  73.     Inherited Destroy;
  74. end;
  75.  
  76. procedure TUCAniTrayIcon.SetHint (const Value: String);
  77. begin
  78.     if fHint <> Value then begin
  79.         fHint := Value;
  80.         UpdateTray (fVisible);
  81.     end;
  82. end;
  83.  
  84. procedure TUCAniTrayIcon.TrayMessage (var Message: TMessage);
  85. begin
  86.     if not fExclusionLock then begin
  87.         fExclusionLock := True;
  88.         case Message.lParam of
  89.             wm_LButtonDown:   if Assigned (fOnLeftClick) then fOnLeftClick (Self);
  90.             wm_RButtonDown:   if Assigned (fOnRightClick) then fOnRightClick (Self);
  91.         end;
  92.         fExclusionLock := False;
  93.     end;
  94. end;
  95.  
  96. procedure TUCAniTrayIcon.WndProc (var Message: TMessage);
  97. begin
  98.     with Message do if Msg = UCTrayCallBack then try
  99.         TrayMessage (Message);
  100.     except
  101.         Application.HandleException (Self);
  102.     end
  103.     else if (Msg = wm_Timer) and (fAniIcon.Empty = False) and fVisible then begin
  104.          fAniIcon.Animate;
  105.          UpdateTray (fVisible);
  106.     end
  107.     else Result := DefWindowProc (fWindowHandle, Msg, wParam, lParam);
  108. end;
  109.  
  110. procedure TUCAniTrayIcon.SetAniIcon (Value: TAniIcon);
  111. begin
  112.     fAniIcon.Assign (Value);
  113.     UpdateTray (fVisible);
  114. end;
  115.  
  116. procedure TUCAniTrayIcon.SetVisible (Value: Boolean);
  117. begin
  118.     if fVisible <> Value then UpdateTray (Value);
  119.     fVisible := Value;
  120. end;
  121.  
  122. procedure TUCAniTrayIcon.SetAnimate (Value: Boolean);
  123. begin
  124.     if (fAnimate <> Value) then begin
  125.         fAnimate := Value;
  126.         if fAnimate then SetTimer (fWindowHandle, 1, 50, Nil)
  127.         else KillTimer (fWindowHandle, 1);
  128.     end;
  129. end;
  130.  
  131. procedure TUCAniTrayIcon.UpdateTray (Visible: Boolean);
  132. var
  133.     Msg: DWord;
  134.     tid: TNotifyIconData;
  135. begin
  136.     if not (csDesigning in ComponentState) then begin
  137.         tid.cbSize := sizeof (tid);
  138.         tid.Wnd := fWindowHandle;
  139.         tid.uID := 0;
  140.         tid.uFlags := nif_Message + nif_Icon + nif_Tip;
  141.         tid.uCallbackMessage := UCTrayCallBack;
  142.         if fAniIcon.Empty then tid.hIcon := Application.Icon.Handle
  143.         else tid.hIcon := fAniIcon.Icon;
  144.         StrPCopy (tid.szTip, fHint);
  145.  
  146.         if Visible <> fVisible then begin
  147.             if Visible then Msg := nim_Add else Msg := nim_Delete;
  148.         end else Msg := nim_Modify;
  149.  
  150.         Shell_NotifyIcon (Msg, @tid);
  151.     end;
  152. end;
  153.  
  154. procedure Register;
  155. begin
  156.     RegisterComponents ('UnCommon', [TUCAniTrayIcon]);
  157. end;
  158.  
  159. end.
  160.